home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / clx / buffer.lisp < prev    next >
Lisp/Scheme  |  1991-11-07  |  65KB  |  1,793 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;; This file contains definitions for the BUFFER object for Common-Lisp X
  4. ;;; windows version 11
  5.  
  6. ;;;
  7. ;;;             TEXAS INSTRUMENTS INCORPORATED
  8. ;;;                  P.O. BOX 2909
  9. ;;;                   AUSTIN, TEXAS 78769
  10. ;;;
  11. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  12. ;;;
  13. ;;; Permission is granted to any individual or institution to use, copy, modify,
  14. ;;; and distribute this software, provided that this complete copyright and
  15. ;;; permission notice is maintained, intact, in all copies and supporting
  16. ;;; documentation.
  17. ;;;
  18. ;;; Texas Instruments Incorporated provides this software "as is" without
  19. ;;; express or implied warranty.
  20. ;;;
  21.  
  22. ;; A few notes:
  23. ;;
  24. ;;  1. The BUFFER implements a two-way buffered byte / half-word
  25. ;;     / word stream.  Hooks are left for implementing this with a
  26. ;;     shared memory buffer, or with effenciency hooks to the network
  27. ;;     code.
  28. ;;
  29. ;;  2. The BUFFER object uses overlapping displaced arrays for
  30. ;;     inserting and removing bytes half-words and words.
  31. ;;
  32. ;;  3. The BYTE component of these arrays is written to a STREAM
  33. ;;     associated with the BUFFER.  The stream has its own buffer.
  34. ;;     This may be made more efficient by using the Zetalisp
  35. ;;     :Send-Output-Buffer operation.
  36. ;;
  37. ;;  4. The BUFFER object is INCLUDED in the DISPLAY object.
  38. ;;     This was done to reduce access time when sending requests,
  39. ;;     while maintaing some code modularity.
  40. ;;     Several buffer functions are duplicated (with-buffer,
  41. ;;     buffer-force-output, close-buffer) to keep the naming
  42. ;;     conventions consistent.
  43. ;;
  44. ;;  5. A nother layer of software is built on top of this for generating
  45. ;;     both client and server interface routines, given a specification
  46. ;;     of the protocol. (see the INTERFACE file)
  47. ;;
  48. ;;  6. Care is taken to leave the buffer pointer (buffer-bbuf) set to
  49. ;;     a point after a complete request.  This is to ensure that a partial
  50. ;;     request won't be left after aborts (e.g. control-abort on a lispm).
  51.  
  52. (in-package :xlib)
  53.  
  54. (defconstant *requestsize* 160) ;; Max request size (excluding variable length requests)
  55.  
  56. ;;; This is here instead of in bufmac so that with-display can be
  57. ;;; compiled without macros and bufmac being loaded.
  58.  
  59. (defmacro with-buffer ((buffer &key timeout inline)
  60.                &body body &environment env)
  61.   ;; This macro is for use in a multi-process environment.  It provides
  62.   ;; exclusive access to the local buffer object for request generation and
  63.   ;; reply processing.
  64.   `(macrolet ((with-buffer ((buffer &key timeout) &body body)
  65.         ;; Speedup hack for lexically nested with-buffers
  66.         `(progn
  67.            (progn ,buffer ,@(and timeout `(,timeout)) nil)
  68.            ,@body)))
  69.      ,(if (and (null inline) (macroexpand '(use-closures) env))
  70.       `(flet ((.with-buffer-body. () ,@body))
  71.          #+clx-ansi-common-lisp
  72.          (declare (dynamic-extent #'.with-buffer-body.))
  73.          (with-buffer-function ,buffer ,timeout #'.with-buffer-body.))
  74.     (let ((buf (if (or (symbolp buffer) (constantp buffer))
  75.                buffer
  76.              '.buffer.)))
  77.       `(let (,@(unless (eq buf buffer) `((,buf ,buffer))))
  78.          ,@(unless (eq buf buffer) `((declare (type buffer ,buf))))
  79.          ,(declare-bufmac)
  80.          (when (buffer-dead ,buf)
  81.            (x-error 'closed-display :display ,buf))
  82.          (holding-lock ((buffer-lock ,buf) ,buf "CLX Display Lock"
  83.                 ,@(and timeout `(:timeout ,timeout)))
  84.            ,@body))))))
  85.  
  86. (defun with-buffer-function (buffer timeout function)
  87.   (declare (type display buffer)
  88.        (type (or null number) timeout)
  89.        (type function function)
  90.        #+clx-ansi-common-lisp
  91.        (dynamic-extent function)
  92.        #+(and lispm (not clx-ansi-common-lisp))
  93.        (sys:downward-funarg function))
  94.   (with-buffer (buffer :timeout timeout :inline t)
  95.     (funcall function)))
  96.  
  97. ;;; The following are here instead of in bufmac so that event-case can
  98. ;;; be compiled without macros and bufmac being loaded.
  99.  
  100. (defmacro read-card8 (byte-index)
  101.   `(aref-card8 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  102.  
  103. (defmacro read-int8 (byte-index)
  104.   `(aref-int8 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  105.  
  106. (defmacro read-card16 (byte-index)
  107.   #+clx-overlapping-arrays
  108.   `(aref-card16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1)))
  109.   #-clx-overlapping-arrays
  110.   `(aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  111.  
  112. (defmacro read-int16 (byte-index)
  113.   #+clx-overlapping-arrays
  114.   `(aref-int16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1)))
  115.   #-clx-overlapping-arrays
  116.   `(aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  117.  
  118. (defmacro read-card32 (byte-index)
  119.   #+clx-overlapping-arrays
  120.   `(aref-card32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
  121.   #-clx-overlapping-arrays
  122.   `(aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  123.  
  124. (defmacro read-int32 (byte-index)
  125.   #+clx-overlapping-arrays
  126.   `(aref-int32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
  127.   #-clx-overlapping-arrays
  128.   `(aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  129.  
  130. (defmacro read-card29 (byte-index)
  131.   #+clx-overlapping-arrays
  132.   `(aref-card29 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
  133.   #-clx-overlapping-arrays
  134.   `(aref-card29 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  135.  
  136. (defmacro event-code (reply-buffer)
  137.   ;; The reply-buffer structure is used for events.
  138.   ;; The size slot is used for the event code.
  139.   `(reply-size ,reply-buffer))
  140.  
  141. (defmacro reading-event ((event &rest options) &body body)
  142.   (declare (arglist (buffer &key sizes) &body body))
  143.   ;; BODY may contain calls to (READ32 &optional index) etc.
  144.   ;; These calls will read from the input buffer at byte
  145.   ;; offset INDEX.  If INDEX is not supplied, then the next
  146.   ;; word, half-word or byte is returned.
  147.   `(with-buffer-input (,event ,@options) ,@body))
  148.  
  149. (defmacro with-buffer-input ((reply-buffer &key display (sizes '(8 16 32)) index)
  150.                  &body body)
  151.   (unless (listp sizes) (setq sizes (list sizes)))
  152.   ;; 160 is a special hack for client-message-events
  153.   (when (set-difference sizes '(0 8 16 32 160 256))
  154.     (error "Illegal sizes in ~a" sizes))
  155.   `(let ((%reply-buffer ,reply-buffer)
  156.      ,@(and display `((%buffer ,display))))
  157.      (declare (type reply-buffer %reply-buffer)
  158.           ,@(and display '((type display %buffer))))
  159.      ,(declare-bufmac)
  160.      ,@(and display '(%buffer))
  161.      (let* ((buffer-boffset (the array-index ,(or index 0)))
  162.         #-clx-overlapping-arrays
  163.         (buffer-bbuf (reply-ibuf8 %reply-buffer))
  164.         #+clx-overlapping-arrays
  165.         ,@(append
  166.         (when (member 8 sizes)
  167.           `((buffer-bbuf (reply-ibuf8 %reply-buffer))))
  168.         (when (or (member 16 sizes) (member 160 sizes))
  169.           `((buffer-woffset (index-ash buffer-boffset -1))
  170.             (buffer-wbuf (reply-ibuf16 %reply-buffer))))
  171.         (when (member 32 sizes)
  172.           `((buffer-loffset (index-ash buffer-boffset -2))
  173.             (buffer-lbuf (reply-ibuf32 %reply-buffer))))))
  174.        (declare (type array-index buffer-boffset))
  175.        #-clx-overlapping-arrays
  176.        (declare (type buffer-bytes buffer-bbuf)
  177.         (array-register buffer-bbuf))
  178.        #+clx-overlapping-arrays
  179.        ,@(append
  180.        (when (member 8 sizes)
  181.          '((declare (type buffer-bytes buffer-bbuf)
  182.             (array-register buffer-bbuf))))
  183.        (when (member 16 sizes)
  184.          '((declare (type array-index buffer-woffset))
  185.            (declare (type buffer-words buffer-wbuf)
  186.             (array-register buffer-wbuf))))
  187.        (when (member 32 sizes)
  188.          '((declare (type array-index buffer-loffset))
  189.            (declare (type buffer-longs buffer-lbuf)
  190.             (array-register buffer-lbuf)))))
  191.        buffer-boffset
  192.        #-clx-overlapping-arrays
  193.        buffer-bbuf
  194.        #+clx-overlapping-arrays
  195.        ,@(append
  196.        (when (member 8  sizes) '(buffer-bbuf))
  197.        (when (member 16 sizes) '(buffer-woffset buffer-wbuf))
  198.        (when (member 32 sizes) '(buffer-loffset buffer-lbuf)))
  199.        #+clx-overlapping-arrays
  200.        (macrolet ((%buffer-sizes () ',sizes))
  201.      ,@body)
  202.        #-clx-overlapping-arrays
  203.        ,@body)))
  204.  
  205. (defun make-buffer (output-size constructor &rest options)
  206.   (declare (dynamic-extent options))
  207.   ;; Output-Size is the output-buffer size in bytes.
  208.   (let ((byte-output (make-array output-size :element-type 'card8
  209.                  :initial-element 0)))
  210.     (apply constructor
  211.        :size output-size
  212.        :obuf8 byte-output
  213.        #+clx-overlapping-arrays
  214.        :obuf16
  215.        #+clx-overlapping-arrays
  216.        (make-array (index-ash output-size -1)
  217.                :element-type 'overlap16
  218.                :displaced-to byte-output)
  219.        #+clx-overlapping-arrays
  220.        :obuf32
  221.        #+clx-overlapping-arrays
  222.        (make-array (index-ash output-size -2)
  223.                :element-type 'overlap32
  224.                :displaced-to byte-output)
  225.        options))) 
  226.  
  227. (defun make-reply-buffer (size)
  228.   ;; Size is the buffer size in bytes
  229.   (let ((byte-input (make-array size :element-type 'card8
  230.                 :initial-element 0)))
  231.     (make-reply-buffer-internal
  232.       :size size
  233.       :ibuf8 byte-input
  234.       #+clx-overlapping-arrays
  235.       :ibuf16
  236.       #+clx-overlapping-arrays
  237.       (make-array (index-ash size -1)
  238.           :element-type 'overlap16
  239.           :displaced-to byte-input)
  240.       #+clx-overlapping-arrays
  241.       :ibuf32
  242.       #+clx-overlapping-arrays
  243.       (make-array (index-ash size -2)
  244.           :element-type 'overlap32
  245.           :displaced-to byte-input))))
  246.  
  247. (defun buffer-ensure-size (buffer size)
  248.   (declare (type buffer buffer)
  249.        (type array-index size))
  250.   (when (index> size (buffer-size buffer))
  251.     (with-buffer (buffer)
  252.       (buffer-flush buffer)
  253.       (let* ((new-buffer-size (index-ash 1 (integer-length (index1- size))))
  254.          (new-buffer (make-array new-buffer-size :element-type 'card8
  255.                      :initial-element 0)))
  256.     (setf (buffer-obuf8 buffer) new-buffer)
  257.     #+clx-overlapping-arrays
  258.     (setf (buffer-obuf16 buffer)
  259.           (make-array (index-ash new-buffer-size -1)
  260.               :element-type 'overlap16
  261.               :displaced-to new-buffer)
  262.           (buffer-obuf32 buffer)
  263.           (make-array (index-ash new-buffer-size -2)
  264.               :element-type 'overlap32
  265.               :displaced-to new-buffer))))))
  266.  
  267. (defun buffer-pad-request (buffer pad)
  268.   (declare (type buffer buffer)
  269.        (type array-index pad))
  270.   (unless (index-zerop pad)
  271.     (when (index> (index+ (buffer-boffset buffer) pad)
  272.           (buffer-size buffer))
  273.       (buffer-flush buffer))
  274.     (incf (buffer-boffset buffer) pad)
  275.     (unless (index-zerop (index-mod (buffer-boffset buffer) 4))
  276.       (buffer-flush buffer))))
  277.  
  278. (declaim (inline buffer-new-request-number))
  279.  
  280. (defun buffer-new-request-number (buffer)
  281.   (declare (type buffer buffer))
  282.   (setf (buffer-request-number buffer)
  283.     (ldb (byte 16 0) (1+ (buffer-request-number buffer)))))
  284.  
  285. (defun with-buffer-request-function (display gc-force request-function)
  286.   (declare (type display display)
  287.        (type (or null gcontext) gc-force))
  288.   (declare (type function request-function)
  289.        #+clx-ansi-common-lisp
  290.        (dynamic-extent request-function)
  291.        #+(and lispm (not clx-ansi-common-lisp))
  292.        (sys:downward-funarg request-function))
  293.   (with-buffer (display :inline t)
  294.     (multiple-value-prog1
  295.       (progn
  296.     (when gc-force (force-gcontext-changes-internal gc-force))
  297.     (without-aborts (funcall request-function display)))
  298.       (display-invoke-after-function display))))
  299.  
  300. (defun with-buffer-request-function-nolock (display gc-force request-function)
  301.   (declare (type display display)
  302.        (type (or null gcontext) gc-force))
  303.   (declare (type function request-function)
  304.        #+clx-ansi-common-lisp
  305.        (dynamic-extent request-function)
  306.        #+(and lispm (not clx-ansi-common-lisp))
  307.        (sys:downward-funarg request-function))
  308.   (multiple-value-prog1
  309.     (progn
  310.       (when gc-force (force-gcontext-changes-internal gc-force))
  311.       (without-aborts (funcall request-function display)))
  312.     (display-invoke-after-function display)))
  313.  
  314. (defstruct (pending-command (:copier nil) (:predicate nil))
  315.   (sequence 0 :type card16)
  316.   (reply-buffer nil :type (or null reply-buffer))
  317.   (process nil)
  318.   (next nil #-explorer :type #-explorer (or null pending-command)))
  319.  
  320. (defun with-buffer-request-and-reply-function
  321.        (display multiple-reply request-function reply-function)
  322.   (declare (type display display)
  323.        (type boolean multiple-reply))
  324.   (declare (type function request-function reply-function)
  325.        #+clx-ansi-common-lisp
  326.        (dynamic-extent request-function reply-function)
  327.        #+(and lispm (not clx-ansi-common-lisp))
  328.        (sys:downward-funarg request-function reply-function))
  329.   (let ((pending-command nil)
  330.     (reply-buffer nil))
  331.     (declare (type (or null pending-command) pending-command)
  332.          (type (or null reply-buffer) reply-buffer))
  333.     (unwind-protect
  334.     (progn 
  335.       (with-buffer (display :inline t)
  336.         (setq pending-command (start-pending-command display))
  337.         (without-aborts (funcall request-function display))
  338.         (buffer-force-output display)
  339.         (display-invoke-after-function display))
  340.       (cond (multiple-reply
  341.          (loop
  342.            (setq reply-buffer (read-reply display pending-command))
  343.            (when (funcall reply-function display reply-buffer) (return nil))
  344.            (deallocate-reply-buffer (shiftf reply-buffer nil))))
  345.         (t
  346.          (setq reply-buffer (read-reply display pending-command))
  347.          (funcall reply-function display reply-buffer))))
  348.       (when reply-buffer (deallocate-reply-buffer reply-buffer))
  349.       (when pending-command (stop-pending-command display pending-command)))))
  350.  
  351. ;;
  352. ;; Buffer stream operations
  353. ;;
  354.  
  355. (defun buffer-write (vector buffer start end)
  356.   ;; Write out VECTOR from START to END into BUFFER
  357.   ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER
  358.   (declare (type buffer buffer)
  359.        (type array-index start end))
  360.   (when (buffer-dead buffer)
  361.     (x-error 'closed-display :display buffer))
  362.   (wrap-buf-output (buffer)
  363.     (funcall (buffer-write-function buffer) vector buffer start end))
  364.   nil)
  365.  
  366. (defun buffer-flush (buffer)
  367.   ;; Write the buffer contents to the server stream - doesn't force-output the stream
  368.   ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER
  369.   (declare (type buffer buffer))
  370.   (unless (buffer-flush-inhibit buffer)
  371.     (let ((boffset (buffer-boffset buffer)))
  372.       (declare (type array-index boffset))
  373.       (when (index-plusp boffset)
  374.     (buffer-write (buffer-obuf8 buffer) buffer 0 boffset)
  375.     (setf (buffer-boffset buffer) 0)
  376.     (setf (buffer-last-request buffer) nil))))
  377.   nil)
  378.  
  379. (defmacro with-buffer-flush-inhibited ((buffer) &body body)
  380.   (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.)))
  381.     `(let* (,@(and (not (eq buf buffer)) `((,buf ,buffer)))
  382.         (.saved-buffer-flush-inhibit. (buffer-flush-inhibit ,buf)))
  383.        (unwind-protect
  384.        (progn
  385.          (setf (buffer-flush-inhibit ,buf) t)
  386.          ,@body)
  387.      (setf (buffer-flush-inhibit ,buf) .saved-buffer-flush-inhibit.)))))
  388.  
  389. (defun buffer-force-output (buffer)
  390.   ;; Output is normally buffered, this forces any buffered output to the server.
  391.   (declare (type buffer buffer))
  392.   (when (buffer-dead buffer)
  393.     (x-error 'closed-display :display buffer))
  394.   (buffer-flush buffer)
  395.   (wrap-buf-output (buffer)
  396.     (without-aborts
  397.       (funcall (buffer-force-output-function buffer) buffer)))
  398.   nil)
  399.  
  400. (defun close-buffer (buffer &key abort)
  401.   ;; Close the host connection in BUFFER
  402.   (declare (type buffer buffer))
  403.   (unless (null (buffer-output-stream buffer))
  404.     (wrap-buf-output (buffer)
  405.       (funcall (buffer-close-function buffer) buffer :abort abort))
  406.     (setf (buffer-dead buffer) t)
  407.     ;; Zap pointers to the streams, to ensure they're GC'd
  408.     (setf (buffer-output-stream buffer) nil)
  409.     (setf (buffer-input-stream buffer) nil)
  410.     )
  411.   nil)
  412.  
  413. (defun buffer-input  (buffer vector start end &optional timeout)
  414.   ;; Read into VECTOR from the buffer stream
  415.   ;; Timeout, when non-nil, is in seconds
  416.   ;; Returns non-nil if EOF encountered
  417.   ;; Returns :TIMEOUT when timeout exceeded
  418.   (declare (type buffer buffer)
  419.        (type vector vector)
  420.        (type array-index start end)
  421.        (type (or null number) timeout))
  422.   (declare (values eof-p))
  423.   (when (buffer-dead buffer)
  424.     (x-error 'closed-display :display buffer))
  425.   (unless (= start end)
  426.     (let ((result
  427.         (wrap-buf-input (buffer)
  428.           (funcall (buffer-input-function buffer)
  429.                buffer vector start end timeout))))
  430.       (unless (or (null result) (eq result :timeout))
  431.     (close-buffer buffer))
  432.       result)))
  433.  
  434. (defun buffer-input-wait  (buffer timeout)
  435.   ;; Timeout, when non-nil, is in seconds
  436.   ;; Returns non-nil if EOF encountered
  437.   ;; Returns :TIMEOUT when timeout exceeded
  438.   (declare (type buffer buffer)
  439.        (type (or null number) timeout))
  440.   (declare (values timeout))
  441.   (when (buffer-dead buffer)
  442.     (x-error 'closed-display :display buffer))
  443.   (let ((result
  444.       (wrap-buf-input (buffer)
  445.         (funcall (buffer-input-wait-function buffer)
  446.              buffer timeout))))
  447.     (unless (or (null result) (eq result :timeout))
  448.       (close-buffer buffer))
  449.     result))
  450.  
  451. (defun buffer-listen (buffer)
  452.   ;; Returns T if there is input available for the buffer. This should never
  453.   ;; block, so it can be called from the scheduler.
  454.   (declare (type buffer buffer))
  455.   (declare (values input-available))
  456.   (or (not (null (buffer-dead buffer)))
  457.       (wrap-buf-input (buffer)
  458.     (funcall (buffer-listen-function buffer) buffer))))
  459.  
  460. ;;; Reading sequences of strings
  461.  
  462. ;;; a list of pascal-strings with card8 lengths, no padding in between
  463. ;;; can't use read-sequence-char
  464. (defun read-sequence-string (buffer-bbuf length nitems result-type
  465.                  &optional (buffer-boffset 0))
  466.   (declare (type buffer-bytes buffer-bbuf)
  467.        (type array-index length nitems buffer-boffset))
  468.   length
  469.   (with-vector (buffer-bbuf buffer-bytes)
  470.     (let ((result (make-sequence result-type nitems)))
  471.       (do* ((index 0 (index+ index 1 string-length))
  472.         (count 0 (index1+ count))
  473.         (string-length 0)
  474.         (string ""))
  475.        ((index>= count nitems)
  476.         result)
  477.     (declare (type array-index index count string-length)
  478.          (type string string))
  479.     (setq string-length (read-card8 index)
  480.           string (make-sequence 'string string-length))
  481.     (do ((i (index1+ index) (index1+ i))
  482.          (j 0 (index1+ j)))
  483.         ((index>= j string-length)
  484.          (setf (elt result count) string))
  485.       (declare (type array-index i j))
  486.       (setf (aref string j) (card8->char (read-card8 i))))))))
  487.  
  488. ;;; Reading sequences of chars
  489.  
  490. (defun read-sequence-char (reply-buffer result-type nitems &optional transform data
  491.                (start 0) (index 0))
  492.   (declare (type reply-buffer reply-buffer)
  493.        (type t result-type) ;; CL type
  494.        (type array-index nitems start index)
  495.        (type (or null sequence) data))
  496.   (declare (type (or null (function (character) t)) transform)
  497.        #+clx-ansi-common-lisp
  498.        (dynamic-extent transform)
  499.        #+(and lispm (not clx-ansi-common-lisp))
  500.        (sys:downward-funarg transform))
  501.   (if transform 
  502.       (flet ((card8->char->transform (v)
  503.            (declare (type card8 v))
  504.            (funcall transform (card8->char v))))
  505.     #+clx-ansi-common-lisp
  506.     (declare (dynamic-extent #'card8->char->transform))
  507.     (read-sequence-card8
  508.       reply-buffer result-type nitems #'card8->char->transform
  509.       data start index))
  510.     (read-sequence-card8
  511.       reply-buffer result-type nitems #'card8->char
  512.       data start index)))
  513.  
  514. ;;; Reading sequences of card8's
  515.  
  516. (defun read-list-card8 (reply-buffer nitems data start index)
  517.   (declare (type reply-buffer reply-buffer)
  518.        (type array-index nitems start index)
  519.        (type list data))
  520.   (with-buffer-input (reply-buffer :sizes (8) :index index)
  521.     (do* ((j nitems (index- j 1))
  522.       (lst (nthcdr start data)  (cdr lst))
  523.       (index 0 (index+ index 1)))
  524.      ((index-zerop j))
  525.       (declare (type array-index j index)
  526.            (type cons lst))
  527.       (setf (car lst) (read-card8 index)))))
  528.  
  529. (defun read-list-card8-with-transform (reply-buffer nitems data transform start index)
  530.   (declare (type reply-buffer reply-buffer)
  531.        (type array-index nitems start index)
  532.        (type list data))
  533.   (declare (type (function (card8) t) transform)
  534.        #+clx-ansi-common-lisp
  535.        (dynamic-extent transform)
  536.        #+(and lispm (not clx-ansi-common-lisp))
  537.        (sys:downward-funarg transform))
  538.   (with-buffer-input (reply-buffer :sizes (8) :index index)
  539.     (do* ((j nitems (index- j 1))
  540.       (lst (nthcdr start data) (cdr lst))
  541.       (index 0 (index+ index 1)))
  542.      ((index-zerop j))
  543.       (declare (type array-index j index)
  544.            (type cons lst))
  545.       (setf (car lst) (funcall transform (read-card8 index))))))
  546.  
  547. #-lispm
  548. (defun read-simple-array-card8 (reply-buffer nitems data start index)
  549.   (declare (type reply-buffer reply-buffer)
  550.        (type array-index nitems start index)
  551.        (type (simple-array card8 (*)) data))
  552.   (with-vector (data (simple-array card8 (*)))
  553.     (with-buffer-input (reply-buffer :sizes (8))
  554.       (buffer-replace data buffer-bbuf start (index+ start nitems) index))))
  555.  
  556. #-lispm
  557. (defun read-simple-array-card8-with-transform (reply-buffer nitems data transform start index)
  558.   (declare (type reply-buffer reply-buffer)
  559.        (type array-index nitems start index)
  560.        (type (simple-array card8 (*)) data))
  561.   (declare (type (function (card8) card8) transform)
  562.        #+clx-ansi-common-lisp
  563.        (dynamic-extent transform)
  564.        #+(and lispm (not clx-ansi-common-lisp))
  565.        (sys:downward-funarg transform))
  566.   (with-vector (data (simple-array card8 (*)))
  567.     (with-buffer-input (reply-buffer :sizes (8) :index index)
  568.       (do* ((j start (index+ j 1))
  569.         (end (index+ start nitems))
  570.         (index 0 (index+ index 1)))
  571.        ((index>= j end))
  572.     (declare (type array-index j end index))
  573.     (setf (aref data j) (the card8 (funcall transform (read-card8 index))))))))
  574.  
  575. (defun read-vector-card8 (reply-buffer nitems data start index)
  576.   (declare (type reply-buffer reply-buffer)
  577.        (type array-index nitems start index)
  578.        (type vector data))
  579.   (with-vector (data vector)
  580.     (with-buffer-input (reply-buffer :sizes (8) :index index)
  581.       (do* ((j start (index+ j 1))
  582.         (end (index+ start nitems))
  583.         (index 0 (index+ index 1)))
  584.        ((index>= j end))
  585.     (declare (type array-index j end index))
  586.     (setf (aref data j) (read-card8 index))))))
  587.  
  588. (defun read-vector-card8-with-transform (reply-buffer nitems data transform start index)
  589.   (declare (type reply-buffer reply-buffer)
  590.        (type array-index nitems start index)
  591.        (type vector data))
  592.   (declare (type (function (card8) t) transform)
  593.        #+clx-ansi-common-lisp
  594.        (dynamic-extent transform)
  595.        #+(and lispm (not clx-ansi-common-lisp))
  596.        (sys:downward-funarg transform))
  597.   (with-vector (data vector)
  598.     (with-buffer-input (reply-buffer :sizes (8) :index index)
  599.       (do* ((j start (index+ j 1))
  600.         (end (index+ start nitems))
  601.         (index 0 (index+ index 1)))
  602.        ((index>= j end))
  603.     (declare (type array-index j end index))
  604.     (setf (aref data j) (funcall transform (read-card8 index)))))))
  605.  
  606. (defun read-sequence-card8 (reply-buffer result-type nitems &optional transform data
  607.                 (start 0) (index 0))
  608.   (declare (type reply-buffer reply-buffer)
  609.        (type t result-type) ;; CL type
  610.        (type array-index nitems start index)
  611.        (type (or null sequence) data))
  612.   (declare (type (or null (function (card8) t)) transform)
  613.        #+clx-ansi-common-lisp
  614.        (dynamic-extent transform)
  615.        #+(and lispm (not clx-ansi-common-lisp))
  616.        (sys:downward-funarg transform))
  617.   (let ((result (or data (make-sequence result-type nitems))))
  618.     (typecase result
  619.       (list
  620.     (if transform 
  621.         (read-list-card8-with-transform
  622.           reply-buffer nitems result transform start index)
  623.       (read-list-card8 reply-buffer nitems result start index)))
  624.       #-lispm
  625.       ((simple-array card8 (*))
  626.        (if transform 
  627.        (read-simple-array-card8-with-transform
  628.          reply-buffer nitems result transform start index)
  629.      (read-simple-array-card8 reply-buffer nitems result start index)))
  630.       (t
  631.     (if transform 
  632.         (read-vector-card8-with-transform
  633.           reply-buffer nitems result transform start index)
  634.       (read-vector-card8 reply-buffer nitems result start index))))
  635.     result))
  636.  
  637. ;;; For now, perhaps performance it isn't worth doing better?
  638.  
  639. (defun read-sequence-int8 (reply-buffer result-type nitems &optional transform data
  640.                (start 0) (index 0))
  641.   (declare (type reply-buffer reply-buffer)
  642.        (type t result-type) ;; CL type
  643.        (type array-index nitems start index)
  644.        (type (or null sequence) data))
  645.   (declare (type (or null (function (int8) t)) transform)
  646.        #+clx-ansi-common-lisp
  647.        (dynamic-extent transform)
  648.        #+(and lispm (not clx-ansi-common-lisp))
  649.        (sys:downward-funarg transform))
  650.   (if transform 
  651.       (flet ((card8->int8->transform (v)
  652.            (declare (type card8 v))
  653.            (funcall transform (card8->int8 v))))
  654.     #+clx-ansi-common-lisp
  655.     (declare (dynamic-extent #'card8->int8->transform))
  656.     (read-sequence-card8
  657.       reply-buffer result-type nitems #'card8->int8->transform
  658.       data start index))
  659.     (read-sequence-card8
  660.       reply-buffer result-type nitems #'card8->int8
  661.       data start index)))
  662.  
  663. ;;; Reading sequences of card16's
  664.  
  665. (defun read-list-card16 (reply-buffer nitems data start index)
  666.   (declare (type reply-buffer reply-buffer)
  667.        (type array-index nitems start index)
  668.        (type list data))
  669.   (with-buffer-input (reply-buffer :sizes (16) :index index)
  670.     (do* ((j nitems (index- j 1))
  671.       (lst (nthcdr start data) (cdr lst))
  672.       (index 0 (index+ index 2)))
  673.      ((index-zerop j))
  674.       (declare (type array-index j index)
  675.            (type cons lst))
  676.       (setf (car lst) (read-card16 index)))))
  677.  
  678. (defun read-list-card16-with-transform (reply-buffer nitems data transform start index)
  679.   (declare (type reply-buffer reply-buffer)
  680.        (type array-index nitems start index)
  681.        (type list data))
  682.   (declare (type (function (card16) t) transform)
  683.        #+clx-ansi-common-lisp
  684.        (dynamic-extent transform)
  685.        #+(and lispm (not clx-ansi-common-lisp))
  686.        (sys:downward-funarg transform))
  687.   (with-buffer-input (reply-buffer :sizes (16) :index index)
  688.     (do* ((j nitems (index- j 1))
  689.       (lst (nthcdr start data) (cdr lst))
  690.       (index 0 (index+ index 2)))
  691.      ((index-zerop j))
  692.       (declare (type array-index j index)
  693.            (type cons lst))
  694.       (setf (car lst) (funcall transform (read-card16 index))))))
  695.  
  696. #-lispm
  697. (defun read-simple-array-card16 (reply-buffer nitems data start index)
  698.   (declare (type reply-buffer reply-buffer)
  699.        (type array-index nitems start index)
  700.        (type (simple-array card16 (*)) data))
  701.   (with-vector (data (simple-array card16 (*)))
  702.     (with-buffer-input (reply-buffer :sizes (16) :index index)
  703.       #-clx-overlapping-arrays
  704.       (do* ((j start (index+ j 1))
  705.         (end (index+ start nitems))
  706.         (index 0 (index+ index 2)))
  707.        ((index>= j end))
  708.     (declare (type array-index j end index))
  709.     (setf (aref data j) (the card16 (read-card16 index))))
  710.       #+clx-overlapping-arrays
  711.       (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2)))))
  712.  
  713. #-lispm
  714. (defun read-simple-array-card16-with-transform (reply-buffer nitems data transform start index)
  715.   (declare (type reply-buffer reply-buffer)
  716.        (type array-index nitems start index)
  717.        (type (simple-array card16 (*)) data))
  718.   (declare (type (function (card16) card16) transform)
  719.        #+clx-ansi-common-lisp
  720.        (dynamic-extent transform)
  721.        #+(and lispm (not clx-ansi-common-lisp))
  722.        (sys:downward-funarg transform))
  723.   (with-vector (data (simple-array card16 (*)))
  724.     (with-buffer-input (reply-buffer :sizes (16) :index index)
  725.       (do* ((j start (index+ j 1))
  726.         (end (index+ start nitems))
  727.         (index 0 (index+ index 2)))
  728.        ((index>= j end))
  729.     (declare (type array-index j end index))
  730.     (setf (aref data j) (the card16 (funcall transform (read-card16 index))))))))
  731.  
  732. (defun read-vector-card16 (reply-buffer nitems data start index)
  733.   (declare (type reply-buffer reply-buffer)
  734.        (type array-index nitems start index)
  735.        (type vector data))
  736.   (with-vector (data vector)
  737.     (with-buffer-input (reply-buffer :sizes (16) :index index)
  738.       #-clx-overlapping-arrays
  739.       (do* ((j start (index+ j 1))
  740.         (end (index+ start nitems))
  741.         (index 0 (index+ index 2)))
  742.        ((index>= j end))
  743.     (declare (type array-index j end index))
  744.     (setf (aref data j) (read-card16 index)))
  745.       #+clx-overlapping-arrays
  746.       (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2)))))
  747.  
  748. (defun read-vector-card16-with-transform (reply-buffer nitems data transform start index)
  749.   (declare (type reply-buffer reply-buffer)
  750.        (type array-index nitems start index)
  751.        (type vector data))
  752.   (declare (type (function (card16) t) transform)
  753.        #+clx-ansi-common-lisp
  754.        (dynamic-extent transform)
  755.        #+(and lispm (not clx-ansi-common-lisp))
  756.        (sys:downward-funarg transform))
  757.   (with-vector (data vector)
  758.     (with-buffer-input (reply-buffer :sizes (16) :index index)
  759.       (do* ((j start (index+ j 1))
  760.         (end (index+ start nitems))
  761.         (index 0 (index+ index 2)))
  762.        ((index>= j end))
  763.     (declare (type array-index j end index))
  764.     (setf (aref data j) (funcall transform (read-card16 index)))))))
  765.  
  766. (defun read-sequence-card16 (reply-buffer result-type nitems &optional transform data
  767.                  (start 0) (index 0))
  768.   (declare (type reply-buffer reply-buffer)
  769.        (type t result-type) ;; CL type
  770.        (type array-index nitems start index)
  771.        (type (or null sequence) data))
  772.   (declare (type (or null (function (card16) t)) transform)
  773.        #+clx-ansi-common-lisp
  774.        (dynamic-extent transform)
  775.        #+(and lispm (not clx-ansi-common-lisp))
  776.        (sys:downward-funarg transform))
  777.   (let ((result (or data (make-sequence result-type nitems))))
  778.     (typecase result
  779.       (list
  780.     (if transform 
  781.         (read-list-card16-with-transform reply-buffer nitems result transform start index)
  782.       (read-list-card16 reply-buffer nitems result start index)))
  783.       #-lispm
  784.       ((simple-array card16 (*))
  785.        (if transform 
  786.        (read-simple-array-card16-with-transform
  787.          reply-buffer nitems result transform start index)
  788.      (read-simple-array-card16 reply-buffer nitems result start index)))
  789.       (t
  790.     (if transform 
  791.         (read-vector-card16-with-transform
  792.           reply-buffer nitems result transform start index)
  793.       (read-vector-card16 reply-buffer nitems result start index))))
  794.     result))
  795.   
  796. ;;; For now, perhaps performance it isn't worth doing better?
  797.  
  798. (defun read-sequence-int16 (reply-buffer result-type nitems &optional transform data
  799.                 (start 0) (index 0))
  800.   (declare (type reply-buffer reply-buffer)
  801.        (type t result-type) ;; CL type
  802.        (type array-index nitems start index)
  803.        (type (or null sequence) data))
  804.   (declare (type (or null (function (int16) t)) transform)
  805.        #+clx-ansi-common-lisp
  806.        (dynamic-extent transform)
  807.        #+(and lispm (not clx-ansi-common-lisp))
  808.        (sys:downward-funarg transform))
  809.   (if transform 
  810.       (flet ((card16->int16->transform (v)
  811.            (declare (type card16 v))
  812.            (funcall transform (card16->int16 v))))
  813.     #+clx-ansi-common-lisp
  814.     (declare (dynamic-extent #'card16->int16->transform))
  815.     (read-sequence-card16
  816.       reply-buffer result-type nitems #'card16->int16->transform
  817.       data start index))
  818.     (read-sequence-card16
  819.       reply-buffer result-type nitems #'card16->int16
  820.       data start index)))
  821.  
  822. ;;; Reading sequences of card32's
  823.  
  824. (defun read-list-card32 (reply-buffer nitems data start index)
  825.   (declare (type reply-buffer reply-buffer)
  826.        (type array-index nitems start index)
  827.        (type list data))
  828.   (with-buffer-input (reply-buffer :sizes (32) :index index)
  829.     (do* ((j nitems (index- j 1))
  830.       (lst (nthcdr start data) (cdr lst))
  831.       (index 0 (index+ index 4)))
  832.      ((index-zerop j))
  833.       (declare (type array-index j index)
  834.            (type cons lst))
  835.       (setf (car lst) (read-card32 index)))))
  836.  
  837. (defun read-list-card32-with-transform (reply-buffer nitems data transform start index)
  838.   (declare (type reply-buffer reply-buffer)
  839.        (type array-index nitems start index)
  840.        (type list data))
  841.   (declare (type (function (card32) t) transform)
  842.        #+clx-ansi-common-lisp
  843.        (dynamic-extent transform)
  844.        #+(and lispm (not clx-ansi-common-lisp))
  845.        (sys:downward-funarg transform))
  846.   (with-buffer-input (reply-buffer :sizes (32) :index index)
  847.     (do* ((j nitems (index- j 1))
  848.       (lst (nthcdr start data) (cdr lst))
  849.       (index 0 (index+ index 4)))
  850.      ((index-zerop j))
  851.       (declare (type array-index j index)
  852.            (type cons lst))
  853.       (setf (car lst) (funcall transform (read-card32 index))))))
  854.  
  855. #-lispm
  856. (defun read-simple-array-card32 (reply-buffer nitems data start index)
  857.   (declare (type reply-buffer reply-buffer)
  858.        (type array-index nitems start index)
  859.        (type (simple-array card32 (*)) data))
  860.   (with-vector (data (simple-array card32 (*)))
  861.     (with-buffer-input (reply-buffer :sizes (32) :index index)
  862.       #-clx-overlapping-arrays
  863.       (do* ((j start (index+ j 1))
  864.         (end (index+ start nitems))
  865.         (index 0 (index+ index 4)))
  866.        ((index>= j end))
  867.     (declare (type array-index j end index))
  868.     (setf (aref data j) (the card32 (read-card32 index))))
  869.       #+clx-overlapping-arrays
  870.       (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4)))))
  871.  
  872. #-lispm
  873. (defun read-simple-array-card32-with-transform (reply-buffer nitems data transform start index)
  874.   (declare (type reply-buffer reply-buffer)
  875.        (type array-index nitems start index)
  876.        (type (simple-array card32 (*)) data))
  877.   (declare (type (function (card32) card32) transform)
  878.        #+clx-ansi-common-lisp
  879.        (dynamic-extent transform)
  880.        #+(and lispm (not clx-ansi-common-lisp))
  881.        (sys:downward-funarg transform))
  882.   (with-vector (data (simple-array card32 (*)))
  883.     (with-buffer-input (reply-buffer :sizes (32) :index index)
  884.       (do* ((j start (index+ j 1))
  885.         (end (index+ start nitems))
  886.         (index 0 (index+ index 4)))
  887.        ((index>= j end))
  888.     (declare (type array-index j end index))
  889.     (setf (aref data j) (the card32 (funcall transform (read-card32 index))))))))
  890.  
  891. (defun read-vector-card32 (reply-buffer nitems data start index)
  892.   (declare (type reply-buffer reply-buffer)
  893.        (type array-index nitems start index)
  894.        (type vector data))
  895.   (with-vector (data vector)
  896.     (with-buffer-input (reply-buffer :sizes (32) :index index)
  897.       #-clx-overlapping-arrays
  898.       (do* ((j start (index+ j 1))
  899.         (end (index+ start nitems))
  900.         (index 0 (index+ index 4)))
  901.        ((index>= j end))
  902.     (declare (type array-index j end index))
  903.     (setf (aref data j) (read-card32 index)))
  904.       #+clx-overlapping-arrays
  905.       (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4)))))
  906.  
  907. (defun read-vector-card32-with-transform (reply-buffer nitems data transform start index)
  908.   (declare (type reply-buffer reply-buffer)
  909.        (type array-index nitems start index)
  910.        (type vector data))
  911.   (declare (type (function (card32) t) transform)
  912.        #+clx-ansi-common-lisp
  913.        (dynamic-extent transform)
  914.        #+(and lispm (not clx-ansi-common-lisp))
  915.        (sys:downward-funarg transform))
  916.   (with-vector (data vector)
  917.     (with-buffer-input (reply-buffer :sizes (32) :index index)
  918.       (do* ((j start (index+ j 1))
  919.         (end (index+ start nitems))
  920.         (index 0 (index+ index 4)))
  921.        ((index>= j end))
  922.     (declare (type array-index j end index))
  923.     (setf (aref data j) (funcall transform (read-card32 index)))))))
  924.  
  925. (defun read-sequence-card32 (reply-buffer result-type nitems &optional transform data
  926.                  (start 0) (index 0))
  927.   (declare (type reply-buffer reply-buffer)
  928.        (type t result-type) ;; CL type
  929.        (type array-index nitems start index)
  930.        (type (or null sequence) data))
  931.   (declare (type (or null (function (card32) t)) transform)
  932.        #+clx-ansi-common-lisp
  933.        (dynamic-extent transform)
  934.        #+(and lispm (not clx-ansi-common-lisp))
  935.        (sys:downward-funarg transform))
  936.   (let ((result (or data (make-sequence result-type nitems))))
  937.     (typecase result
  938.       (list
  939.     (if transform 
  940.         (read-list-card32-with-transform reply-buffer nitems result transform start index)
  941.       (read-list-card32 reply-buffer nitems result start index)))
  942.       #-lispm
  943.       ((simple-array card32 (*))
  944.        (if transform 
  945.        (read-simple-array-card32-with-transform
  946.          reply-buffer nitems result transform start index)
  947.      (read-simple-array-card32 reply-buffer nitems result start index)))
  948.       (t
  949.     (if transform 
  950.         (read-vector-card32-with-transform
  951.           reply-buffer nitems result transform start index)
  952.       (read-vector-card32 reply-buffer nitems result start index))))
  953.     result))
  954.  
  955. ;;; For now, perhaps performance it isn't worth doing better?
  956.  
  957. (defun read-sequence-int32 (reply-buffer result-type nitems &optional transform data
  958.                 (start 0) (index 0))
  959.   (declare (type reply-buffer reply-buffer)
  960.        (type t result-type) ;; CL type
  961.        (type array-index nitems start index)
  962.        (type (or null sequence) data))
  963.   (declare (type (or null (function (int32) t)) transform)
  964.        #+clx-ansi-common-lisp
  965.        (dynamic-extent transform)
  966.        #+(and lispm (not clx-ansi-common-lisp))
  967.        (sys:downward-funarg transform))
  968.   (if transform 
  969.       (flet ((card32->int32->transform (v)
  970.            (declare (type card32 v))
  971.            (funcall transform (card32->int32 v))))
  972.     #+clx-ansi-common-lisp
  973.     (declare (dynamic-extent #'card32->int32->transform))
  974.     (read-sequence-card32
  975.       reply-buffer result-type nitems #'card32->int32->transform
  976.       data start index))
  977.     (read-sequence-card32
  978.       reply-buffer result-type nitems #'card32->int32
  979.       data start index)))
  980.  
  981. ;;; Writing sequences of chars
  982.  
  983. (defun write-sequence-char
  984.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  985.   (declare (type buffer buffer)
  986.        (type sequence data)
  987.        (type array-index boffset start end))
  988.   (declare (type (or null (function (t) character)) transform)
  989.        #+clx-ansi-common-lisp
  990.        (dynamic-extent transform)
  991.        #+(and lispm (not clx-ansi-common-lisp))
  992.        (sys:downward-funarg transform))
  993.   (if transform 
  994.       (flet ((transform->char->card8 (x)
  995.            (char->card8 (the character (funcall transform x)))))
  996.     #+clx-ansi-common-lisp
  997.     (declare (dynamic-extent #'transform->char->card8))
  998.     (write-sequence-card8
  999.       buffer boffset data start end #'transform->char->card8))
  1000.     (write-sequence-card8 buffer boffset data start end #'char->card8)))
  1001.  
  1002. ;;; Writing sequences of card8's
  1003.  
  1004. (defun write-list-card8 (buffer boffset data start end)
  1005.   (declare (type buffer buffer)
  1006.        (type list data)
  1007.        (type array-index boffset start end))
  1008.   (writing-buffer-chunks card8
  1009.              ((lst (nthcdr start data)))
  1010.              ((type list lst))
  1011.     (dotimes (j chunk)
  1012.       (declare (type array-index j))
  1013.       #-ti (write-card8 j (pop lst))        ;TI Compiler bug
  1014.       #+ti (setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop lst))
  1015.       ))
  1016.   nil)
  1017.  
  1018. (defun write-list-card8-with-transform (buffer boffset data start end transform)
  1019.   (declare (type buffer buffer)
  1020.        (type list data)
  1021.        (type array-index boffset start end))
  1022.   (declare (type (function (t) card8) transform)
  1023.        #+clx-ansi-common-lisp
  1024.        (dynamic-extent transform)
  1025.        #+(and lispm (not clx-ansi-common-lisp))
  1026.        (sys:downward-funarg transform))
  1027.   (writing-buffer-chunks card8
  1028.              ((lst (nthcdr start data)))
  1029.              ((type list lst))
  1030.     (dotimes (j chunk)
  1031.       (declare (type array-index j))
  1032.       (write-card8 j (funcall transform (pop lst)))))
  1033.   nil)
  1034.  
  1035. ;;; Should really write directly from data, instead of into the buffer first
  1036. #-lispm
  1037. (defun write-simple-array-card8 (buffer boffset data start end)
  1038.   (declare (type buffer buffer)
  1039.        (type (simple-array card8 (*)) data)
  1040.        (type array-index boffset start end))
  1041.   (with-vector (data (simple-array card8 (*)))
  1042.     (writing-buffer-chunks card8
  1043.                ((index start (index+ index chunk)))
  1044.                ((type array-index index))
  1045.       (buffer-replace buffer-bbuf data
  1046.               buffer-boffset
  1047.               (index+ buffer-boffset chunk)
  1048.               index)))
  1049.   nil)
  1050.  
  1051. #-lispm
  1052. (defun write-simple-array-card8-with-transform (buffer boffset data start end transform)
  1053.   (declare (type buffer buffer)
  1054.        (type (simple-array card8 (*)) data)
  1055.        (type array-index boffset start end))
  1056.   (declare (type (function (card8) card8) transform)
  1057.        #+clx-ansi-common-lisp
  1058.        (dynamic-extent transform)
  1059.        #+(and lispm (not clx-ansi-common-lisp))
  1060.        (sys:downward-funarg transform))
  1061.   (with-vector (data (simple-array card8 (*)))
  1062.     (writing-buffer-chunks card8
  1063.                ((index start))
  1064.                ((type array-index index))
  1065.       (dotimes (j chunk)
  1066.     (declare (type array-index j))
  1067.     (write-card8 j (funcall transform (aref data index)))
  1068.     (setq index (index+ index 1)))))
  1069.   nil)
  1070.  
  1071. (defun write-vector-card8 (buffer boffset data start end)
  1072.   (declare (type buffer buffer)
  1073.        (type vector data)
  1074.        (type array-index boffset start end))
  1075.   (with-vector (data vector)
  1076.     (writing-buffer-chunks card8
  1077.                ((index start))
  1078.                ((type array-index index))
  1079.       (dotimes (j chunk)
  1080.     (declare (type array-index j))
  1081.     (write-card8 j (aref data index))
  1082.     (setq index (index+ index 1)))))
  1083.   nil)
  1084.  
  1085. (defun write-vector-card8-with-transform (buffer boffset data start end transform)
  1086.   (declare (type buffer buffer)
  1087.        (type vector data)
  1088.        (type array-index boffset start end))
  1089.   (declare (type (function (t) card8) transform)
  1090.        #+clx-ansi-common-lisp
  1091.        (dynamic-extent transform)
  1092.        #+(and lispm (not clx-ansi-common-lisp))
  1093.        (sys:downward-funarg transform))
  1094.   (with-vector (data vector)
  1095.     (writing-buffer-chunks card8
  1096.                ((index start))
  1097.                ((type array-index index))
  1098.       (dotimes (j chunk)
  1099.     (declare (type array-index j))
  1100.     (write-card8 j (funcall transform (aref data index)))
  1101.     (setq index (index+ index 1)))))
  1102.   nil)
  1103.  
  1104. (defun write-sequence-card8
  1105.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1106.   (declare (type buffer buffer)
  1107.        (type sequence data)
  1108.        (type array-index boffset start end))
  1109.   (declare (type (or null (function (t) card8)) transform)
  1110.        #+clx-ansi-common-lisp
  1111.        (dynamic-extent transform)
  1112.        #+(and lispm (not clx-ansi-common-lisp))
  1113.        (sys:downward-funarg transform))
  1114.   (typecase data
  1115.     (list
  1116.       (if transform
  1117.       (write-list-card8-with-transform buffer boffset data start end transform)
  1118.       (write-list-card8 buffer boffset data start end)))
  1119.     #-lispm
  1120.     ((simple-array card8 (*))
  1121.      (if transform
  1122.      (write-simple-array-card8-with-transform buffer boffset data start end transform)
  1123.      (write-simple-array-card8 buffer boffset data start end)))
  1124.     (t
  1125.       (if transform
  1126.       (write-vector-card8-with-transform buffer boffset data start end transform)
  1127.       (write-vector-card8 buffer boffset data start end)))))
  1128.  
  1129. ;;; For now, perhaps performance it isn't worth doing better?
  1130.  
  1131. (defun write-sequence-int8
  1132.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1133.   (declare (type buffer buffer)
  1134.        (type sequence data)
  1135.        (type array-index boffset start end))
  1136.   (declare (type (or null (function (t) int8)) transform)
  1137.        #+clx-ansi-common-lisp
  1138.        (dynamic-extent transform)
  1139.        #+(and lispm (not clx-ansi-common-lisp))
  1140.        (sys:downward-funarg transform))
  1141.   (if transform 
  1142.       (flet ((transform->int8->card8 (x)
  1143.            (int8->card8 (the int8 (funcall transform x)))))
  1144.     #+clx-ansi-common-lisp
  1145.     (declare (dynamic-extent #'transform->int8->card8))
  1146.     (write-sequence-card8
  1147.       buffer boffset data start end #'transform->int8->card8))
  1148.       (write-sequence-card8 buffer boffset data start end #'int8->card8)))
  1149.  
  1150. ;;; Writing sequences of card16's
  1151.  
  1152. (defun write-list-card16 (buffer boffset data start end)
  1153.   (declare (type buffer buffer)
  1154.        (type list data)
  1155.        (type array-index boffset start end))
  1156.   (writing-buffer-chunks card16
  1157.              ((lst (nthcdr start data)))
  1158.              ((type list lst))
  1159.     ;; Depends upon the chunks being an even multiple of card16's big
  1160.     (do ((j 0 (index+ j 2)))
  1161.     ((index>= j chunk))
  1162.       (declare (type array-index j))
  1163.       (write-card16 j (pop lst))))
  1164.   nil)
  1165.  
  1166. (defun write-list-card16-with-transform (buffer boffset data start end transform)
  1167.   (declare (type buffer buffer)
  1168.        (type list data)
  1169.        (type array-index boffset start end))
  1170.   (declare (type (function (t) card16) transform)
  1171.        #+clx-ansi-common-lisp
  1172.        (dynamic-extent transform)
  1173.        #+(and lispm (not clx-ansi-common-lisp))
  1174.        (sys:downward-funarg transform))
  1175.   (writing-buffer-chunks card16
  1176.              ((lst (nthcdr start data)))
  1177.              ((type list lst))
  1178.     ;; Depends upon the chunks being an even multiple of card16's big
  1179.     (do ((j 0 (index+ j 2)))
  1180.     ((index>= j chunk))
  1181.       (declare (type array-index j))
  1182.       (write-card16 j (funcall transform (pop lst)))))
  1183.   nil)
  1184.  
  1185. #-lispm
  1186. (defun write-simple-array-card16 (buffer boffset data start end)
  1187.   (declare (type buffer buffer)
  1188.        (type (simple-array card16 (*)) data)
  1189.        (type array-index boffset start end))
  1190.   (with-vector (data (simple-array card16 (*)))
  1191.     (writing-buffer-chunks card16
  1192.                ((index start))
  1193.                ((type array-index index))
  1194.       ;; Depends upon the chunks being an even multiple of card16's big
  1195.       (do ((j 0 (index+ j 2)))
  1196.       ((index>= j chunk))
  1197.     (declare (type array-index j))
  1198.     (write-card16 j (aref data index))
  1199.     (setq index (index+ index 1)))
  1200.       ;; overlapping case
  1201.       (let ((length (floor chunk 2)))
  1202.     (buffer-replace buffer-wbuf data
  1203.             buffer-woffset
  1204.             (index+ buffer-woffset length)
  1205.             index)
  1206.     (setq index (index+ index length)))))
  1207.   nil)
  1208.  
  1209. #-lispm
  1210. (defun write-simple-array-card16-with-transform (buffer boffset data start end transform)
  1211.   (declare (type buffer buffer)
  1212.        (type (simple-array card16 (*)) data)
  1213.        (type array-index boffset start end))
  1214.   (declare (type (function (card16) card16) transform)
  1215.        #+clx-ansi-common-lisp
  1216.        (dynamic-extent transform)
  1217.        #+(and lispm (not clx-ansi-common-lisp))
  1218.        (sys:downward-funarg transform))
  1219.   (with-vector (data (simple-array card16 (*)))
  1220.     (writing-buffer-chunks card16
  1221.                ((index start))
  1222.                ((type array-index index))
  1223.       ;; Depends upon the chunks being an even multiple of card16's big
  1224.       (do ((j 0 (index+ j 2)))
  1225.       ((index>= j chunk))
  1226.     (declare (type array-index j))
  1227.     (write-card16 j (funcall transform (aref data index)))
  1228.     (setq index (index+ index 1)))))
  1229.   nil)
  1230.  
  1231. (defun write-vector-card16 (buffer boffset data start end)
  1232.   (declare (type buffer buffer)
  1233.        (type vector data)
  1234.        (type array-index boffset start end))
  1235.   (with-vector (data vector)
  1236.     (writing-buffer-chunks card16
  1237.                ((index start))
  1238.                ((type array-index index))
  1239.       ;; Depends upon the chunks being an even multiple of card16's big
  1240.       (do ((j 0 (index+ j 2)))
  1241.       ((index>= j chunk))
  1242.     (declare (type array-index j))
  1243.     (write-card16 j (aref data index))
  1244.     (setq index (index+ index 1)))
  1245.       ;; overlapping case
  1246.       (let ((length (floor chunk 2)))
  1247.     (buffer-replace buffer-wbuf data
  1248.             buffer-woffset
  1249.             (index+ buffer-woffset length)
  1250.             index)
  1251.     (setq index (index+ index length)))))
  1252.   nil)
  1253.  
  1254. (defun write-vector-card16-with-transform (buffer boffset data start end transform)
  1255.   (declare (type buffer buffer)
  1256.        (type vector data)
  1257.        (type array-index boffset start end))
  1258.   (declare (type (function (t) card16) transform)
  1259.        #+clx-ansi-common-lisp
  1260.        (dynamic-extent transform)
  1261.        #+(and lispm (not clx-ansi-common-lisp))
  1262.        (sys:downward-funarg transform))
  1263.   (with-vector (data vector)
  1264.     (writing-buffer-chunks card16
  1265.                ((index start))
  1266.                ((type array-index index))
  1267.       ;; Depends upon the chunks being an even multiple of card16's big
  1268.       (do ((j 0 (index+ j 2)))
  1269.       ((index>= j chunk))
  1270.     (declare (type array-index j))
  1271.     (write-card16 j (funcall transform (aref data index)))
  1272.     (setq index (index+ index 1)))))
  1273.   nil)
  1274.  
  1275. (defun write-sequence-card16
  1276.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1277.   (declare (type buffer buffer)
  1278.        (type sequence data)
  1279.        (type array-index boffset start end))
  1280.   (declare (type (or null (function (t) card16)) transform)
  1281.        #+clx-ansi-common-lisp
  1282.        (dynamic-extent transform)
  1283.        #+(and lispm (not clx-ansi-common-lisp))
  1284.        (sys:downward-funarg transform))
  1285.   (typecase data
  1286.     (list
  1287.       (if transform
  1288.       (write-list-card16-with-transform buffer boffset data start end transform)
  1289.       (write-list-card16 buffer boffset data start end)))
  1290.     #-lispm
  1291.     ((simple-array card16 (*))
  1292.      (if transform
  1293.      (write-simple-array-card16-with-transform buffer boffset data start end transform)
  1294.      (write-simple-array-card16 buffer boffset data start end)))
  1295.     (t
  1296.       (if transform
  1297.       (write-vector-card16-with-transform buffer boffset data start end transform)
  1298.       (write-vector-card16 buffer boffset data start end)))))
  1299.  
  1300. ;;; Writing sequences of int16's
  1301.  
  1302. (defun write-list-int16 (buffer boffset data start end)
  1303.   (declare (type buffer buffer)
  1304.        (type list data)
  1305.        (type array-index boffset start end))
  1306.   (writing-buffer-chunks int16
  1307.              ((lst (nthcdr start data)))
  1308.              ((type list lst))
  1309.     ;; Depends upon the chunks being an even multiple of int16's big
  1310.     (do ((j 0 (index+ j 2)))
  1311.     ((index>= j chunk))
  1312.       (declare (type array-index j))
  1313.       (write-int16 j (pop lst))))
  1314.   nil)
  1315.  
  1316. (defun write-list-int16-with-transform (buffer boffset data start end transform)
  1317.   (declare (type buffer buffer)
  1318.        (type list data)
  1319.        (type array-index boffset start end))
  1320.   (declare (type (function (t) int16) transform)
  1321.        #+clx-ansi-common-lisp
  1322.        (dynamic-extent transform)
  1323.        #+(and lispm (not clx-ansi-common-lisp))
  1324.        (sys:downward-funarg transform))
  1325.   (writing-buffer-chunks int16
  1326.              ((lst (nthcdr start data)))
  1327.              ((type list lst))
  1328.     ;; Depends upon the chunks being an even multiple of int16's big
  1329.     (do ((j 0 (index+ j 2)))
  1330.     ((index>= j chunk))
  1331.       (declare (type array-index j))
  1332.       (write-int16 j (funcall transform (pop lst)))))
  1333.   nil)
  1334.  
  1335. #-lispm
  1336. (defun write-simple-array-int16 (buffer boffset data start end)
  1337.   (declare (type buffer buffer)
  1338.        (type (simple-array int16 (*)) data)
  1339.        (type array-index boffset start end))
  1340.   (with-vector (data (simple-array int16 (*)))
  1341.     (writing-buffer-chunks int16
  1342.                ((index start))
  1343.                ((type array-index index))
  1344.       ;; Depends upon the chunks being an even multiple of int16's big
  1345.       (do ((j 0 (index+ j 2)))
  1346.       ((index>= j chunk))
  1347.     (declare (type array-index j))
  1348.     (write-int16 j (aref data index))
  1349.     (setq index (index+ index 1)))
  1350.       ;; overlapping case
  1351.       (let ((length (floor chunk 2)))
  1352.     (buffer-replace buffer-wbuf data
  1353.             buffer-woffset
  1354.             (index+ buffer-woffset length)
  1355.             index)
  1356.     (setq index (index+ index length)))))
  1357.   nil)
  1358.  
  1359. #-lispm
  1360. (defun write-simple-array-int16-with-transform (buffer boffset data start end transform)
  1361.   (declare (type buffer buffer)
  1362.        (type (simple-array int16 (*)) data)
  1363.        (type array-index boffset start end))
  1364.   (declare (type (function (int16) int16) transform)
  1365.        #+clx-ansi-common-lisp
  1366.        (dynamic-extent transform)
  1367.        #+(and lispm (not clx-ansi-common-lisp))
  1368.        (sys:downward-funarg transform))
  1369.   (with-vector (data (simple-array int16 (*)))
  1370.     (writing-buffer-chunks int16
  1371.                ((index start))
  1372.                ((type array-index index))
  1373.       ;; Depends upon the chunks being an even multiple of int16's big
  1374.       (do ((j 0 (index+ j 2)))
  1375.       ((index>= j chunk))
  1376.     (declare (type array-index j))
  1377.     (write-int16 j (funcall transform (aref data index)))
  1378.     (setq index (index+ index 1)))))
  1379.   nil)
  1380.  
  1381. (defun write-vector-int16 (buffer boffset data start end)
  1382.   (declare (type buffer buffer)
  1383.        (type vector data)
  1384.        (type array-index boffset start end))
  1385.   (with-vector (data vector)
  1386.     (writing-buffer-chunks int16
  1387.                ((index start))
  1388.                ((type array-index index))
  1389.       ;; Depends upon the chunks being an even multiple of int16's big
  1390.       (do ((j 0 (index+ j 2)))
  1391.       ((index>= j chunk))
  1392.     (declare (type array-index j))
  1393.     (write-int16 j (aref data index))
  1394.     (setq index (index+ index 1)))
  1395.       ;; overlapping case
  1396.       (let ((length (floor chunk 2)))
  1397.     (buffer-replace buffer-wbuf data
  1398.             buffer-woffset
  1399.             (index+ buffer-woffset length)
  1400.             index)
  1401.     (setq index (index+ index length)))))
  1402.   nil)
  1403.  
  1404. (defun write-vector-int16-with-transform (buffer boffset data start end transform)
  1405.   (declare (type buffer buffer)
  1406.        (type vector data)
  1407.        (type array-index boffset start end))
  1408.   (declare (type (function (t) int16) transform)
  1409.        #+clx-ansi-common-lisp
  1410.        (dynamic-extent transform)
  1411.        #+(and lispm (not clx-ansi-common-lisp))
  1412.        (sys:downward-funarg transform))
  1413.   (with-vector (data vector)
  1414.     (writing-buffer-chunks int16
  1415.                ((index start))
  1416.                ((type array-index index))
  1417.       ;; Depends upon the chunks being an even multiple of int16's big
  1418.       (do ((j 0 (index+ j 2)))
  1419.       ((index>= j chunk))
  1420.     (declare (type array-index j))
  1421.     (write-int16 j (funcall transform (aref data index)))
  1422.     (setq index (index+ index 1)))))
  1423.   nil)
  1424.  
  1425. (defun write-sequence-int16
  1426.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1427.   (declare (type buffer buffer)
  1428.        (type sequence data)
  1429.        (type array-index boffset start end))
  1430.   (declare (type (or null (function (t) int16)) transform)
  1431.        #+clx-ansi-common-lisp
  1432.        (dynamic-extent transform)
  1433.        #+(and lispm (not clx-ansi-common-lisp))
  1434.        (sys:downward-funarg transform))
  1435.   (typecase data
  1436.     (list
  1437.       (if transform
  1438.       (write-list-int16-with-transform buffer boffset data start end transform)
  1439.       (write-list-int16 buffer boffset data start end)))
  1440.     #-lispm
  1441.     ((simple-array int16 (*))
  1442.      (if transform
  1443.      (write-simple-array-int16-with-transform buffer boffset data start end transform)
  1444.      (write-simple-array-int16 buffer boffset data start end)))
  1445.     (t
  1446.       (if transform
  1447.       (write-vector-int16-with-transform buffer boffset data start end transform)
  1448.       (write-vector-int16 buffer boffset data start end)))))
  1449.  
  1450. ;;; Writing sequences of card32's
  1451.  
  1452. (defun write-list-card32 (buffer boffset data start end)
  1453.   (declare (type buffer buffer)
  1454.        (type list data)
  1455.        (type array-index boffset start end))
  1456.   (writing-buffer-chunks card32
  1457.              ((lst (nthcdr start data)))
  1458.              ((type list lst))
  1459.     ;; Depends upon the chunks being an even multiple of card32's big
  1460.     (do ((j 0 (index+ j 4)))
  1461.     ((index>= j chunk))
  1462.       (declare (type array-index j))
  1463.       (write-card32 j (pop lst))))
  1464.   nil)
  1465.  
  1466. (defun write-list-card32-with-transform (buffer boffset data start end transform)
  1467.   (declare (type buffer buffer)
  1468.        (type list data)
  1469.        (type array-index boffset start end))
  1470.   (declare (type (function (t) card32) transform)
  1471.        #+clx-ansi-common-lisp
  1472.        (dynamic-extent transform)
  1473.        #+(and lispm (not clx-ansi-common-lisp))
  1474.        (sys:downward-funarg transform))
  1475.   (writing-buffer-chunks card32
  1476.              ((lst (nthcdr start data)))
  1477.              ((type list lst))
  1478.     ;; Depends upon the chunks being an even multiple of card32's big
  1479.     (do ((j 0 (index+ j 4)))
  1480.     ((index>= j chunk))
  1481.       (declare (type array-index j))
  1482.       (write-card32 j (funcall transform (pop lst)))))
  1483.   nil)
  1484.  
  1485. #-lispm
  1486. (defun write-simple-array-card32 (buffer boffset data start end)
  1487.   (declare (type buffer buffer)
  1488.        (type (simple-array card32 (*)) data)
  1489.        (type array-index boffset start end))
  1490.   (with-vector (data (simple-array card32 (*)))
  1491.     (writing-buffer-chunks card32
  1492.                ((index start))
  1493.                ((type array-index index))
  1494.       ;; Depends upon the chunks being an even multiple of card32's big
  1495.       (do ((j 0 (index+ j 4)))
  1496.       ((index>= j chunk))
  1497.     (declare (type array-index j))
  1498.     (write-card32 j (aref data index))
  1499.     (setq index (index+ index 1)))
  1500.       ;; overlapping case
  1501.       (let ((length (floor chunk 4)))
  1502.     (buffer-replace buffer-lbuf data
  1503.             buffer-loffset
  1504.             (index+ buffer-loffset length)
  1505.             index)
  1506.     (setq index (index+ index length)))))
  1507.   nil)
  1508.  
  1509. #-lispm
  1510. (defun write-simple-array-card32-with-transform (buffer boffset data start end transform)
  1511.   (declare (type buffer buffer)
  1512.        (type (simple-array card32 (*)) data)
  1513.        (type array-index boffset start end))
  1514.   (declare (type (function (card32) card32) transform)
  1515.        #+clx-ansi-common-lisp
  1516.        (dynamic-extent transform)
  1517.        #+(and lispm (not clx-ansi-common-lisp))
  1518.        (sys:downward-funarg transform))
  1519.   (with-vector (data (simple-array card32 (*)))
  1520.     (writing-buffer-chunks card32
  1521.                ((index start))
  1522.                ((type array-index index))
  1523.       ;; Depends upon the chunks being an even multiple of card32's big
  1524.       (do ((j 0 (index+ j 4)))
  1525.       ((index>= j chunk))
  1526.     (declare (type array-index j))
  1527.     (write-card32 j (funcall transform (aref data index)))
  1528.     (setq index (index+ index 1)))))
  1529.   nil)
  1530.  
  1531. (defun write-vector-card32 (buffer boffset data start end)
  1532.   (declare (type buffer buffer)
  1533.        (type vector data)
  1534.        (type array-index boffset start end))
  1535.   (with-vector (data vector)
  1536.     (writing-buffer-chunks card32
  1537.                ((index start))
  1538.                ((type array-index index))
  1539.       ;; Depends upon the chunks being an even multiple of card32's big
  1540.       (do ((j 0 (index+ j 4)))
  1541.       ((index>= j chunk))
  1542.     (declare (type array-index j))
  1543.     (write-card32 j (aref data index))
  1544.     (setq index (index+ index 1)))
  1545.       ;; overlapping case
  1546.       (let ((length (floor chunk 4)))
  1547.     (buffer-replace buffer-lbuf data
  1548.             buffer-loffset
  1549.             (index+ buffer-loffset length)
  1550.             index)
  1551.     (setq index (index+ index length)))))
  1552.   nil)
  1553.  
  1554. (defun write-vector-card32-with-transform (buffer boffset data start end transform)
  1555.   (declare (type buffer buffer)
  1556.        (type vector data)
  1557.        (type array-index boffset start end))
  1558.   (declare (type (function (t) card32) transform)
  1559.        #+clx-ansi-common-lisp
  1560.        (dynamic-extent transform)
  1561.        #+(and lispm (not clx-ansi-common-lisp))
  1562.        (sys:downward-funarg transform))
  1563.   (with-vector (data vector)
  1564.     (writing-buffer-chunks card32
  1565.                ((index start))
  1566.                ((type array-index index))
  1567.       ;; Depends upon the chunks being an even multiple of card32's big
  1568.       (do ((j 0 (index+ j 4)))
  1569.       ((index>= j chunk))
  1570.     (declare (type array-index j))
  1571.     (write-card32 j (funcall transform (aref data index)))
  1572.     (setq index (index+ index 1)))))
  1573.   nil)
  1574.  
  1575. (defun write-sequence-card32
  1576.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1577.   (declare (type buffer buffer)
  1578.        (type sequence data)
  1579.        (type array-index boffset start end))
  1580.   (declare (type (or null (function (t) card32)) transform)
  1581.        #+clx-ansi-common-lisp
  1582.        (dynamic-extent transform)
  1583.        #+(and lispm (not clx-ansi-common-lisp))
  1584.        (sys:downward-funarg transform))
  1585.   (typecase data
  1586.     (list
  1587.       (if transform
  1588.       (write-list-card32-with-transform buffer boffset data start end transform)
  1589.       (write-list-card32 buffer boffset data start end)))
  1590.     #-lispm
  1591.     ((simple-array card32 (*))
  1592.      (if transform
  1593.      (write-simple-array-card32-with-transform buffer boffset data start end transform)
  1594.      (write-simple-array-card32 buffer boffset data start end)))
  1595.     (t
  1596.       (if transform
  1597.       (write-vector-card32-with-transform buffer boffset data start end transform)
  1598.       (write-vector-card32 buffer boffset data start end)))))
  1599.  
  1600. ;;; For now, perhaps performance it isn't worth doing better?
  1601.  
  1602. (defun write-sequence-int32
  1603.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1604.   (declare (type buffer buffer)
  1605.        (type sequence data)
  1606.        (type array-index boffset start end))
  1607.   (declare (type (or null (function (t) int32)) transform)
  1608.        #+clx-ansi-common-lisp
  1609.        (dynamic-extent transform)
  1610.        #+(and lispm (not clx-ansi-common-lisp))
  1611.        (sys:downward-funarg transform))
  1612.   (if transform 
  1613.       (flet ((transform->int32->card32 (x)
  1614.            (int32->card32 (the int32 (funcall transform x)))))
  1615.     #+clx-ansi-common-lisp
  1616.     (declare (dynamic-extent #'transform->int32->card32))
  1617.     (write-sequence-card32
  1618.       buffer boffset data start end #'transform->int32->card32))
  1619.     (write-sequence-card32 buffer boffset data start end #'int32->card32)))
  1620.  
  1621. (defun read-bitvector256 (buffer-bbuf boffset data)
  1622.   (declare (type buffer-bytes buffer-bbuf)
  1623.        (type array-index boffset)
  1624.        (type (or null (simple-bit-vector 256)) data))
  1625.   (let ((result (or data (make-array 256 :element-type 'bit :initial-element 0))))
  1626.     (declare (type (simple-bit-vector 256) result)
  1627.          (array-register result))
  1628.     (do ((i (index+ boffset 1) (index+ i 1)) ;; Skip first byte
  1629.      (j 8 (index+ j 8)))
  1630.     ((index>= j 256))
  1631.       (declare (type array-index i j))
  1632.       (do ((byte (aref-card8 buffer-bbuf i) (index-ash byte -1))
  1633.        (k j (index+ k 1)))
  1634.       ((zerop byte)
  1635.        (when data ;; Clear uninitialized bits in data
  1636.          (do ((end (index+ j 8)))
  1637.          ((index= k end))
  1638.            (declare (type array-index end))
  1639.            (setf (aref result k) 0)
  1640.            (index-incf k))))
  1641.     (declare (type array-index k)
  1642.          (type card8 byte))
  1643.     (setf (aref result k) (the bit (logand byte 1)))))
  1644.     result))
  1645.  
  1646. (defun write-bitvector256 (buffer boffset map)
  1647.   (declare (type buffer buffer)
  1648.        (type array-index boffset)
  1649.        (type (simple-array bit (*)) map))
  1650.   (with-buffer-output (buffer :index boffset :sizes 8)
  1651.     (do* ((i (index+ buffer-boffset 1) (index+ i 1))    ; Skip first byte
  1652.       (j 8 (index+ j 8)))        
  1653.      ((index>= j 256))
  1654.       (declare (type array-index i j))
  1655.       (do ((byte 0)
  1656.        (bit (index+ j 7) (index- bit 1)))
  1657.       ((index< bit j)
  1658.        (aset-card8 byte buffer-bbuf i))
  1659.     (declare (type array-index bit)
  1660.          (type card8 byte))
  1661.     (setq byte (the card8 (logior (the card8 (ash byte 1)) (aref map bit))))))))
  1662.  
  1663. ;;; Writing sequences of char2b's
  1664.  
  1665. (defun write-list-char2b (buffer boffset data start end)
  1666.   (declare (type buffer buffer)
  1667.        (type list data)
  1668.        (type array-index boffset start end))
  1669.   (writing-buffer-chunks card16
  1670.              ((lst (nthcdr start data)))
  1671.              ((type list lst))
  1672.     (do ((j 0 (index+ j 2)))
  1673.     ((index>= j (1- chunk)) (setf chunk j))
  1674.       (declare (type array-index j))
  1675.       (write-char2b j (pop lst))))
  1676.   nil)
  1677.  
  1678. (defun write-list-char2b-with-transform (buffer boffset data start end transform)
  1679.   (declare (type buffer buffer)
  1680.        (type list data)
  1681.        (type array-index boffset start end))
  1682.   (declare (type (function (t) card16) transform)
  1683.        #+clx-ansi-common-lisp
  1684.        (dynamic-extent transform)
  1685.        #+(and lispm (not clx-ansi-common-lisp))
  1686.        (sys:downward-funarg transform))
  1687.   (writing-buffer-chunks card16
  1688.              ((lst (nthcdr start data)))
  1689.              ((type list lst))
  1690.     (do ((j 0 (index+ j 2)))
  1691.     ((index>= j (1- chunk)) (setf chunk j))
  1692.       (declare (type array-index j))
  1693.       (write-char2b j (funcall transform (pop lst)))))
  1694.   nil)
  1695.  
  1696. #-lispm
  1697. (defun write-simple-array-char2b (buffer boffset data start end)
  1698.   (declare (type buffer buffer)
  1699.        (type (simple-array card16 (*)) data)
  1700.        (type array-index boffset start end))
  1701.   (with-vector (data (simple-array card16 (*)))
  1702.     (writing-buffer-chunks card16
  1703.                ((index start))
  1704.                ((type array-index index))
  1705.       (do ((j 0 (index+ j 2)))
  1706.       ((index>= j (1- chunk)) (setf chunk j))
  1707.     (declare (type array-index j))
  1708.     (write-char2b j (aref data index))
  1709.     (setq index (index+ index 1)))))
  1710.   nil)
  1711.  
  1712. #-lispm
  1713. (defun write-simple-array-char2b-with-transform (buffer boffset data start end transform)
  1714.   (declare (type buffer buffer)
  1715.        (type (simple-array card16 (*)) data)
  1716.        (type array-index boffset start end))
  1717.   (declare (type (function (card16) card16) transform)
  1718.        #+clx-ansi-common-lisp
  1719.        (dynamic-extent transform)
  1720.        #+(and lispm (not clx-ansi-common-lisp))
  1721.        (sys:downward-funarg transform))
  1722.   (with-vector (data (simple-array card16 (*)))
  1723.     (writing-buffer-chunks card16
  1724.                ((index start))
  1725.                ((type array-index index))
  1726.       (do ((j 0 (index+ j 2)))
  1727.       ((index>= j (1- chunk)) (setf chunk j))
  1728.     (declare (type array-index j))
  1729.     (write-char2b j (funcall transform (aref data index)))
  1730.     (setq index (index+ index 1)))))
  1731.   nil)
  1732.  
  1733. (defun write-vector-char2b (buffer boffset data start end)
  1734.   (declare (type buffer buffer)
  1735.        (type vector data)
  1736.        (type array-index boffset start end))
  1737.   (with-vector (data vector)
  1738.     (writing-buffer-chunks card16
  1739.                ((index start))
  1740.                ((type array-index index))
  1741.       (do ((j 0 (index+ j 2)))
  1742.       ((index>= j (1- chunk)) (setf chunk j))
  1743.     (declare (type array-index j))
  1744.     (write-char2b j (aref data index))
  1745.     (setq index (index+ index 1)))))
  1746.   nil)
  1747.  
  1748. (defun write-vector-char2b-with-transform (buffer boffset data start end transform)
  1749.   (declare (type buffer buffer)
  1750.        (type vector data)
  1751.        (type array-index boffset start end))
  1752.   (declare (type (function (t) card16) transform)
  1753.        #+clx-ansi-common-lisp
  1754.        (dynamic-extent transform)
  1755.        #+(and lispm (not clx-ansi-common-lisp))
  1756.        (sys:downward-funarg transform))
  1757.   (with-vector (data vector)
  1758.     (writing-buffer-chunks card16
  1759.                ((index start))
  1760.                ((type array-index index))
  1761.       (do ((j 0 (index+ j 2)))
  1762.       ((index>= j (1- chunk)) (setf chunk j))
  1763.     (declare (type array-index j))
  1764.     (write-char2b j (funcall transform (aref data index)))
  1765.     (setq index (index+ index 1)))))
  1766.   nil)
  1767.  
  1768. (defun write-sequence-char2b
  1769.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1770.   (declare (type buffer buffer)
  1771.        (type sequence data)
  1772.        (type array-index boffset start end))
  1773.   (declare (type (or null (function (t) card16)) transform)
  1774.        #+clx-ansi-common-lisp
  1775.        (dynamic-extent transform)
  1776.        #+(and lispm (not clx-ansi-common-lisp))
  1777.        (sys:downward-funarg transform))
  1778.   (typecase data
  1779.     (list
  1780.       (if transform
  1781.       (write-list-char2b-with-transform buffer boffset data start end transform)
  1782.       (write-list-char2b buffer boffset data start end)))
  1783.     #-lispm
  1784.     ((simple-array card16 (*))
  1785.      (if transform
  1786.      (write-simple-array-char2b-with-transform buffer boffset data start end transform)
  1787.      (write-simple-array-char2b buffer boffset data start end)))
  1788.     (t
  1789.       (if transform
  1790.       (write-vector-char2b-with-transform buffer boffset data start end transform)
  1791.       (write-vector-char2b buffer boffset data start end)))))
  1792.  
  1793.